home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / mwdenote.scm < prev    next >
Text File  |  1999-04-19  |  9KB  |  290 lines
  1. ;"mwdenote.scm" Syntactic Environments
  2. ; Copyright 1992 William Clinger
  3. ;
  4. ; Permission to copy this software, in whole or in part, to use this
  5. ; software for any lawful purpose, and to redistribute this software
  6. ; is granted subject to the restriction that all copies made of this
  7. ; software must include this copyright notice in full.
  8. ;
  9. ; I also request that you send me a copy of any improvements that you
  10. ; make to this software so that they may be incorporated within it to
  11. ; the benefit of the Scheme community.
  12.  
  13. ;;;; Syntactic environments.
  14.  
  15. ; A syntactic environment maps identifiers to denotations,
  16. ; where a denotation is one of
  17. ;
  18. ;    (special <special>)
  19. ;    (macro <rules> <env>)
  20. ;    (identifier <id>)
  21. ;
  22. ; and where <special> is one of
  23. ;
  24. ;    quote
  25. ;    lambda
  26. ;    if
  27. ;    set!
  28. ;    begin
  29. ;    define
  30. ;    define-syntax
  31. ;    let-syntax
  32. ;    letrec-syntax
  33. ;    syntax-rules
  34. ;
  35. ; and where <rules> is a compiled <transformer spec> (see R4RS),
  36. ; <env> is a syntactic environment, and <id> is an identifier.
  37.  
  38. (define mw:standard-syntax-environment
  39.   '((quote         . (special quote))
  40.     (lambda        . (special lambda))
  41.     (if            . (special if))
  42.     (set!          . (special set!))
  43.     (begin         . (special begin))
  44.     (define        . (special define))
  45.     (case          . (special case))               ;; @@ added wdc
  46.     (let           . (special let))                ;; @@ added KAD
  47.     (let*          . (special let*))               ;; @@    "
  48.     (letrec        . (special letrec))             ;; @@    "
  49.     (quasiquote    . (special quasiquote))         ;; @@    "
  50.     (unquote       . (special unquote))            ;; @@    "
  51.     (unquote-splicing . (special unquote-splicing)) ; @@    "
  52.     (do            . (special do))                 ;; @@    "
  53.     (define-syntax . (special define-syntax))
  54.     (let-syntax    . (special let-syntax))
  55.     (letrec-syntax . (special letrec-syntax))
  56.     (syntax-rules  . (special syntax-rules))
  57.     (...           . (identifier ...))
  58.     (:::           . (identifier :::))))
  59.  
  60. ; An unforgeable synonym for lambda, used to expand definitions.
  61.  
  62. (define mw:lambda0 (string->symbol " lambda "))
  63.  
  64. ; The mw:global-syntax-environment will always be a nonempty
  65. ; association list since there is no way to remove the entry
  66. ; for mw:lambda0.  That entry is used as a header by destructive
  67. ; operations.
  68.  
  69. (define mw:global-syntax-environment
  70.   (cons (cons mw:lambda0
  71.           (cdr (assq 'lambda mw:standard-syntax-environment)))
  72.     (mw:syntax-copy mw:standard-syntax-environment)))
  73.  
  74. (define (mw:global-syntax-environment-set! env)
  75.   (set-cdr! mw:global-syntax-environment env))
  76.  
  77. (define (mw:syntax-bind-globally! id denotation)
  78.   (if (and (mw:identifier? denotation)
  79.        (eq? id (mw:identifier-name denotation)))
  80.       (letrec ((remove-bindings-for-id
  81.         (lambda (bindings)
  82.           (cond ((null? bindings) '())
  83.             ((eq? (caar bindings) id)
  84.              (remove-bindings-for-id (cdr bindings)))
  85.             (else (cons (car bindings)
  86.                     (remove-bindings-for-id (cdr bindings))))))))
  87.     (mw:global-syntax-environment-set!
  88.      (remove-bindings-for-id (cdr mw:global-syntax-environment))))
  89.       (let ((x (assq id mw:global-syntax-environment)))
  90.     (if x
  91.         (set-cdr! x denotation)
  92.         (mw:global-syntax-environment-set!
  93.          (cons (cons id denotation)
  94.            (cdr mw:global-syntax-environment)))))))
  95.  
  96. (define (mw:syntax-divert env1 env2)
  97.   (append env2 env1))
  98.  
  99. (define (mw:syntax-extend env ids denotations)
  100.   (mw:syntax-divert env (map cons ids denotations)))
  101.  
  102. (define (mw:syntax-lookup-raw env id)
  103.   (let ((entry (assq id env)))
  104.     (if entry
  105.     (cdr entry)
  106.     #f)))
  107.  
  108. (define (mw:syntax-lookup env id)
  109.   (or (mw:syntax-lookup-raw env id)
  110.       (mw:make-identifier-denotation id)))
  111.  
  112. (define (mw:syntax-assign! env id denotation)
  113.   (let ((entry (assq id env)))
  114.     (if entry
  115.     (set-cdr! entry denotation)
  116.     (mw:bug "Bug detected in mw:syntax-assign!" env id denotation))))
  117.  
  118. (define mw:denote-of-quote
  119.   (mw:syntax-lookup mw:standard-syntax-environment 'quote))
  120.  
  121. (define mw:denote-of-lambda
  122.   (mw:syntax-lookup mw:standard-syntax-environment 'lambda))
  123.  
  124. (define mw:denote-of-if
  125.   (mw:syntax-lookup mw:standard-syntax-environment 'if))
  126.  
  127. (define mw:denote-of-set!
  128.   (mw:syntax-lookup mw:standard-syntax-environment 'set!))
  129.  
  130. (define mw:denote-of-begin
  131.   (mw:syntax-lookup mw:standard-syntax-environment 'begin))
  132.  
  133. (define mw:denote-of-define
  134.   (mw:syntax-lookup mw:standard-syntax-environment 'define))
  135.  
  136. (define mw:denote-of-define-syntax
  137.   (mw:syntax-lookup mw:standard-syntax-environment 'define-syntax))
  138.  
  139. (define mw:denote-of-let-syntax
  140.   (mw:syntax-lookup mw:standard-syntax-environment 'let-syntax))
  141.  
  142. (define mw:denote-of-letrec-syntax
  143.   (mw:syntax-lookup mw:standard-syntax-environment 'letrec-syntax))
  144.  
  145. (define mw:denote-of-syntax-rules
  146.   (mw:syntax-lookup mw:standard-syntax-environment 'syntax-rules))
  147.  
  148. (define mw:denote-of-...
  149.   (mw:syntax-lookup mw:standard-syntax-environment '...))
  150.  
  151. (define mw:denote-of-:::
  152.   (mw:syntax-lookup mw:standard-syntax-environment ':::))
  153.  
  154. (define mw:denote-of-case
  155.   (mw:syntax-lookup mw:standard-syntax-environment 'case))       ;; @@ wdc
  156.  
  157. (define mw:denote-of-let
  158.   (mw:syntax-lookup mw:standard-syntax-environment 'let))        ;; @@ KenD
  159.  
  160. (define mw:denote-of-let*
  161.   (mw:syntax-lookup mw:standard-syntax-environment 'let*))       ;; @@ KenD
  162.  
  163. (define mw:denote-of-letrec
  164.   (mw:syntax-lookup mw:standard-syntax-environment 'letrec))     ;; @@ KenD
  165.  
  166. (define mw:denote-of-quasiquote
  167.   (mw:syntax-lookup mw:standard-syntax-environment 'quasiquote)) ;; @@ KenD
  168.  
  169. (define mw:denote-of-unquote
  170.   (mw:syntax-lookup mw:standard-syntax-environment 'unquote))    ;; @@ KenD
  171.  
  172. (define mw:denote-of-unquote-splicing
  173.   (mw:syntax-lookup mw:standard-syntax-environment 'unquote-splicing)) ;@@ KenD
  174.  
  175. (define mw:denote-of-do
  176.   (mw:syntax-lookup mw:standard-syntax-environment 'do))        ;; @@ KenD
  177.  
  178. (define mw:denote-class car)
  179.  
  180. ;(define (mw:special? denotation)
  181. ;  (eq? (mw:denote-class denotation) 'special))
  182.  
  183. ;(define (mw:macro? denotation)
  184. ;  (eq? (mw:denote-class denotation) 'macro))
  185.  
  186. (define (mw:identifier? denotation)
  187.   (eq? (mw:denote-class denotation) 'identifier))
  188.  
  189. (define (mw:make-identifier-denotation id)
  190.   (list 'identifier id))
  191.  
  192. (define macwork:rules cadr)
  193. (define macwork:env caddr)
  194. (define mw:identifier-name cadr)
  195.  
  196. (define (mw:same-denotation? d1 d2)
  197.   (or (eq? d1 d2)
  198.       (and (mw:identifier? d1)
  199.        (mw:identifier? d2)
  200.        (eq? (mw:identifier-name d1)
  201.         (mw:identifier-name d2)))))
  202.  
  203. ; Renaming of variables.
  204.  
  205. ; Given a datum, strips the suffixes from any symbols that appear within
  206. ; the datum, trying not to copy any more of the datum than necessary.
  207.  
  208. ; @@ rewrote to strip *all* suffixes -- wdc
  209.  
  210. (define mw:strip
  211.   (letrec ((original-symbol
  212.             (lambda (x)
  213.               (let ((s (symbol->string x)))
  214.                 (loop x s 0 (string-length s)))))
  215.            (loop
  216.             (lambda (sym s i n)
  217.               (cond ((= i n) sym)
  218.                     ((char=? (string-ref s i)
  219.                              mw:suffix-character)
  220.                      (string->symbol (substring s 0 i)))
  221.                     (else
  222.                      (loop sym s (+ i 1) n))))))
  223.     (lambda (x)
  224.       (cond ((symbol? x)
  225.              (original-symbol x))
  226.             ((pair? x)
  227.              (let ((y (mw:strip (car x)))
  228.                    (z (mw:strip (cdr x))))
  229.                (if (and (eq? y (car x))
  230.                         (eq? z (cdr x)))
  231.                    x
  232.                    (cons y z))))
  233.             ((vector? x)
  234.              (list->vector (map mw:strip (vector->list x))))
  235.             (else x)))))
  236.  
  237. ; Given a list of identifiers, returns an alist that associates each
  238. ; identifier with a fresh identifier.
  239.  
  240. (define (mw:rename-vars vars)
  241.   (set! mw:renaming-counter (+ mw:renaming-counter 1))
  242.   (let ((suffix (string-append (string mw:suffix-character)
  243.                    (number->string mw:renaming-counter))))
  244.     (map (lambda (var)
  245.        (if (symbol? var)
  246.            (cons var
  247.              (string->symbol
  248.               (string-append (symbol->string var) suffix)))
  249.            (slib:error "Illegal variable" var)))
  250.      vars)))
  251.  
  252. ; Given a syntactic environment env to be extended, an alist returned
  253. ; by mw:rename-vars, and a syntactic environment env2, extends env by
  254. ; binding the fresh identifiers to the denotations of the original
  255. ; identifiers in env2.
  256.  
  257. (define (mw:syntax-alias env alist env2)
  258.   (mw:syntax-divert
  259.    env
  260.    (map (lambda (name-pair)
  261.       (let ((old-name (car name-pair))
  262.         (new-name (cdr name-pair)))
  263.         (cons new-name
  264.           (mw:syntax-lookup env2 old-name))))
  265.     alist)))
  266.  
  267. ; Given a syntactic environment and an alist returned by mw:rename-vars,
  268. ; extends the environment by binding the old identifiers to the fresh
  269. ; identifiers.
  270.  
  271. (define (mw:syntax-rename env alist)
  272.   (mw:syntax-divert env
  273.             (map (lambda (old new)
  274.                (cons old (mw:make-identifier-denotation new)))
  275.              (map car alist)
  276.              (map cdr alist))))
  277.  
  278. ; Given a <formals> and an alist returned by mw:rename-vars that contains
  279. ; a new name for each formal identifier in <formals>, renames the
  280. ; formal identifiers.
  281.  
  282. (define (mw:rename-formals formals alist)
  283.   (cond ((null? formals) '())
  284.     ((pair? formals)
  285.      (cons (cdr (assq (car formals) alist))
  286.            (mw:rename-formals (cdr formals) alist)))
  287.     (else (cdr (assq formals alist)))))
  288.  
  289. (define mw:renaming-counter 0)
  290.